home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue71 / Stack / TraceableClass.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-04-19  |  3.6 KB  |  156 lines
  1. unit TraceableClass;
  2.  
  3. interface
  4.  
  5. type
  6.   {: This class just prints a trace of the different calls to
  7.      methods intervening in object construction and destruction that
  8.      can be modified by the end user. }
  9.   TTraceableBaseClass = class
  10.   public
  11.     procedure      AfterConstruction; override;
  12.     procedure      BeforeDestruction; override;
  13.     constructor Create;
  14.     destructor  Destroy; override;
  15.   end;
  16.  
  17.   {: Derived class provided to show how base and derived classes
  18.      collaborate in construction and destruction. }
  19.   TTraceableClass = class( TTraceableBaseClass )
  20.   public
  21.     procedure      FreeInstance; override;
  22.     class function NewInstance: TObject; override;
  23.  
  24.     procedure      AfterConstruction; override;
  25.     procedure      BeforeDestruction; override;
  26.     constructor Create;
  27.     destructor  Destroy; override;
  28.   end;
  29.  
  30.   TWhenToRaise = (rpNone, rpNewInstance,
  31.                   rpAfterConstruction, rpBaseAfterConstruction, rpCreate, rpBaseCreate );
  32.  
  33. {: Shows a trace of object construction and destruction,
  34.    with the possibility of an exception being raised in different
  35.    steps of the object construction.
  36.  
  37.    This provides an easy way of understing how the whole construction
  38.    and destruction process works normally, as well as in the presence of
  39.    exceptional conditions in each step of the construction process.
  40. }
  41. procedure Trace( when : TWhenToRaise );
  42.  
  43. implementation
  44.  
  45. uses
  46.   SysUtils,
  47.   WMain;
  48.  
  49. var
  50.   WhenToRaise : TWhenToRaise;
  51.  
  52. procedure Trace( when : TWhenToRaise );
  53. var
  54.   obj : TTraceableClass;
  55. begin
  56.   WhenToRaise := when;
  57.   try
  58.     obj := TTraceableClass.Create;
  59.     WriteLn( '     Construction has finished successfully!' );
  60.     obj.Free;
  61.   except
  62.     // Just "eat" the exception, we report it elsewhere
  63.   end;
  64.   WriteLn;
  65. end;
  66.  
  67. {: Raises an exception at the specified moment: in NewInstance, in
  68.    the base class Create, etc.
  69. }
  70. procedure CheckRaise( when : TWhenToRaise );
  71. const
  72.   Place : array[rpNewInstance..rpBaseCreate] of String =
  73.     ( 'NewInstance',
  74.       'AfterConstruction', 'BASE.AfterConstruction',
  75.       'Create', 'BASE.Create' );
  76. var
  77.   msg : string;
  78. begin
  79.   if WhenToRaise = when then begin
  80.     msg := '      ^ Exception raised in ' + Place[when];
  81.     WriteLn( msg );
  82.     raise Exception.Create( msg );
  83.   end;
  84. end;
  85.  
  86. { TTraceableBaseClass }
  87.  
  88. procedure TTraceableBaseClass.AfterConstruction;
  89. begin
  90.   inherited;
  91.   CheckRaise( rpBaseAfterConstruction );
  92.   WriteLn( 'BASE.AfterConstruction' );
  93. end;
  94.  
  95. procedure TTraceableBaseClass.BeforeDestruction;
  96. begin
  97.   inherited;
  98.   WriteLn( 'BASE.BeforeDestruction' );
  99. end;
  100.  
  101. constructor TTraceableBaseClass.Create;
  102. begin
  103.   CheckRaise( rpBaseCreate );
  104.   inherited;
  105.   WriteLn( 'BASE.Create' );
  106. end;
  107.  
  108. destructor TTraceableBaseClass.Destroy;
  109. begin
  110.   WriteLn( 'BASE.Destroy' );
  111.   inherited;
  112. end;
  113.  
  114. { TTraceableClass }
  115.  
  116. procedure TTraceableClass.AfterConstruction;
  117. begin
  118.   inherited;
  119.   CheckRaise( rpAfterConstruction );
  120.   WriteLn( 'AfterConstruction' );
  121. end;
  122.  
  123. procedure TTraceableClass.BeforeDestruction;
  124. begin
  125.   WriteLn( 'BeforeDestruction' );
  126.   inherited;
  127. end;
  128.  
  129. constructor TTraceableClass.Create;
  130. begin
  131.   inherited;
  132.   CheckRaise( rpCreate );
  133.   WriteLn( 'Create' );
  134. end;
  135.  
  136. destructor TTraceableClass.Destroy;
  137. begin
  138.   WriteLn( 'Destroy' );
  139.   inherited;
  140. end;
  141.  
  142. procedure TTraceableClass.FreeInstance;
  143. begin
  144.   inherited;
  145.   WriteLn( 'FreeInstance' );
  146. end;
  147.  
  148. class function TTraceableClass.NewInstance: TObject;
  149. begin
  150.   CheckRaise( rpNewInstance );
  151.   Result := inherited NewInstance;
  152.   WriteLn( 'NewInstance' );
  153. end;
  154.  
  155. end.
  156.